home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Contrib / STk-wtour / lessons / canvas-rubber.stk < prev    next >
Encoding:
Text File  |  1995-12-13  |  688 b   |  30 lines
  1. ;;; Rubber banding
  2. ;;;  (stroke out a box with mousebutton 1)
  3.  
  4. (define x1 0)
  5. (define y1 0)
  6.  
  7. (define (item-delete c)
  8.   (c 'delete 'area))
  9.  
  10. (define (item-mark c x y)
  11.   (set! x1 (c 'canvasx x))
  12.   (set! y1 (c 'canvasy y))
  13.   (item-delete c))
  14.  
  15. (define (item-stroke c x y)
  16.   (set! x (c 'canvasx x))
  17.   (set! y (c 'canvasy y))
  18.   (unless (and (= x1 x) (= y1 y))
  19.      (item-delete c)
  20.      (c 'addtag 'area 'withtag (c 'create 'rectangle x1 y1 x y))))
  21.  
  22.  
  23. (pack (canvas '.c1) :fill "both" :expand #t)
  24.  
  25. (bind .c1 "<ButtonPress-1>"   (lambda (x y) (item-mark .c1 x y)))
  26. (bind .c1 "<B1-Motion>"       (lambda (x y) (item-stroke .c1 x y)))
  27. (bind .c1 "<ButtonRelease-1>" (lambda ()    (item-delete .c1)))
  28.  
  29.  
  30.